VERSION 5.00
Begin VB.UserControl Frame 
   AutoRedraw      =   -1  'True
   ClientHeight    =   1095
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1095
   ControlContainer=   -1  'True
   PropertyPages   =   "Frame.ctx":0000
   ScaleHeight     =   73
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   73
   ToolboxBitmap   =   "Frame.ctx":0023
End
Attribute VB_Name = "Frame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'Windows api
Private Declare Function TextOut _
                Lib "gdi32" _
                Alias "TextOutA" (ByVal hDC As Long, _
                                  ByVal X As Long, _
                                  ByVal Y As Long, _
                                  ByVal lpString As String, _
                                  ByVal nCount As Long) As Long
Private Declare Function lstrlen _
                Lib "kernel32" _
                Alias "lstrlenA" (ByVal lpString As String) As Long

'Protected enum
Enum FrmAlign
    [aLeft]
    [aCenter]
    [aRight]
End Enum

'Properties variables
Dim ctlAllowExpand       As Boolean
Dim ctlExpandStatus      As Boolean
Dim ctlBorder            As Boolean

'Private variables
Private m_BorderColor    As OLE_COLOR
Private m_Caption        As String
Private m_TitleAlign     As FrmAlign
Private m_TitleBackColor As OLE_COLOR
Private m_TitlePadding   As Integer
Private m_OldHeight      As Long
Private m_PanelBackColor As OLE_COLOR
Private TitleHeight      As Integer

Private m_MouseButton    As MouseButtonConstants
Private MouseY           As Single

'Events declaration
Event Click()
Event DblClick()
Event PanelClick()
Event PanelDblClick()
Event TitleClick()
Event TitleDblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event Resize()

' *********************************************************************************
' PROPERTIES
' *********************************************************************************

Public Property Get AllowExpand() As Boolean
    AllowExpand = ctlAllowExpand
End Property

Public Property Let AllowExpand(ByVal NewValue As Boolean)
    ctlAllowExpand = NewValue
    Call RenderFrame
    PropertyChanged "AllowExpand"
End Property

Public Property Get Border() As Boolean
    Border = ctlBorder
End Property

Public Property Let Border(ByVal NewValue As Boolean)
    ctlBorder = NewValue
    Call RenderFrame
    PropertyChanged "Border"
End Property

Public Property Get BorderColor() As OLE_COLOR
    BorderColor = m_BorderColor
End Property

Public Property Let BorderColor(ByVal New_Color As OLE_COLOR)
    m_BorderColor = New_Color
    Call RenderFrame
    PropertyChanged "BorderColor"
End Property

Public Property Get Caption() As String
    Caption = m_Caption
End Property

Public Property Let Caption(ByVal NewValue As String)
    m_Caption = NewValue
    Call RenderFrame
    PropertyChanged "Caption"
End Property

Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(NewValue As Boolean)
    UserControl.Enabled = NewValue
    Call RenderFrame
    PropertyChanged "Enabled"
End Property

Public Property Get Font() As Font
    Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    Call RenderFrame
    PropertyChanged "Font"
End Property

Public Property Get MouseIcon() As Picture
    Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
    Set UserControl.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
End Property

Public Property Get MousePointer() As MousePointerConstants
    MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)

    If New_MousePointer < vbDefault Then New_MousePointer = vbDefault
    If (New_MousePointer > vbSizeAll) And (New_MousePointer <> vbCustom) Then New_MousePointer = vbSizeAll
    UserControl.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
End Property

Public Property Get PanelBackColor() As OLE_COLOR
    PanelBackColor = m_PanelBackColor
End Property

Public Property Let PanelBackColor(ByVal New_Color As OLE_COLOR)
    m_PanelBackColor = New_Color
    Call RenderFrame
    PropertyChanged "PanelBackColor"
End Property

Public Property Get TitleAlign() As FrmAlign
    TitleAlign = m_TitleAlign
End Property

Public Property Let TitleAlign(ByVal NewValue As FrmAlign)
    m_TitleAlign = NewValue
    Call RenderFrame
    PropertyChanged "TitleAlign"
End Property

Public Property Get TitleBackColor() As OLE_COLOR
    TitleBackColor = m_TitleBackColor
End Property

Public Property Let TitleBackColor(ByVal New_Color As OLE_COLOR)
    m_TitleBackColor = New_Color
    Call RenderFrame
    PropertyChanged "TitleBackColor"
End Property

Public Property Get TitleForeColor() As OLE_COLOR
    TitleForeColor = UserControl.ForeColor
End Property

Public Property Let TitleForeColor(ByVal New_Color As OLE_COLOR)
    UserControl.ForeColor() = New_Color
    Call RenderFrame
    PropertyChanged "TitleForeColor"
End Property

Public Property Get TitlePadding() As Integer
    TitlePadding = m_TitlePadding
End Property

Public Property Let TitlePadding(ByVal NewValue As Integer)
    m_TitlePadding = NewValue
    Call RenderFrame
    PropertyChanged "TitlePadding"
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    AllowExpand = PropBag.ReadProperty("AllowExpand", False)
    Border = PropBag.ReadProperty("Border", True)
    BorderColor = PropBag.ReadProperty("BorderColor", &HDBCECC)
    Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName)
    Enabled = PropBag.ReadProperty("Enabled", True)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    UserControl.MousePointer = PropBag.ReadProperty("MousePointer", vbDefault)
    PanelBackColor = PropBag.ReadProperty("PanelBackColor", &HF5F5F5)
    TitleAlign = PropBag.ReadProperty("TitleAlign", 0)
    TitleBackColor = PropBag.ReadProperty("TitleBackColor", &HF2EEEE)
    UserControl.ForeColor = PropBag.ReadProperty("TitleForeColor", vbBlack)
    TitlePadding = PropBag.ReadProperty("TitlePadding", 4)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("AllowExpand", ctlAllowExpand, False)
    Call PropBag.WriteProperty("Border", ctlBorder, True)
    Call PropBag.WriteProperty("BorderColor", m_BorderColor, &HDBCECC)
    Call PropBag.WriteProperty("Caption", m_Caption, Ambient.DisplayName)
    Call PropBag.WriteProperty("Enabled", Enabled, True)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, vbDefault)
    Call PropBag.WriteProperty("PanelBackColor", m_PanelBackColor, &HF5F5F5)
    Call PropBag.WriteProperty("TitleAlign", m_TitleAlign, 0)
    Call PropBag.WriteProperty("TitleBackColor", m_TitleBackColor, &HF2EEEE)
    Call PropBag.WriteProperty("TitleForeColor", UserControl.ForeColor, vbBlack)
    Call PropBag.WriteProperty("TitlePadding", m_TitlePadding, 4)
End Sub

' *********************************************************************************
' FUNCTION
' *********************************************************************************

Public Sub HideExpand()

    If ctlExpandStatus Then
        m_OldHeight = UserControl.ScaleHeight * Screen.TwipsPerPixelY
        UserControl.Height = (TitleHeight * Screen.TwipsPerPixelY) + (TitlePadding + TitlePadding + 1) * Screen.TwipsPerPixelY
        ctlExpandStatus = False
    End If
End Sub

Public Sub ShowExpand()

    If Not ctlExpandStatus Then
        UserControl.Height = m_OldHeight
        ctlExpandStatus = True
    End If
End Sub

Public Function ExpandStatus() As Boolean
    ExpandStatus = ctlExpandStatus
End Function

Public Property Get hwnd() As Long
    hwnd = UserControl.hwnd
End Property

Public Sub Refresh()
    UserControl.Refresh
End Sub

' *********************************************************************************
' USER CONTROL
' *********************************************************************************

Private Sub UserControl_Click()

    If m_MouseButton = vbLeftButton Then
        If MouseY < (TitleHeight + TitlePadding) Then
            'Rasie click event for the frames title
            RaiseEvent TitleClick
        Else
            RaiseEvent PanelClick
        End If
        RaiseEvent Click
    End If
End Sub

Private Sub UserControl_DblClick()
    'Static Expand As Boolean
    
    If (m_MouseButton = vbLeftButton) Then

        'Check mouseY is in between frame title caption.
        If MouseY < (TitleHeight + TitlePadding) Then
            If AllowExpand Then

                'Toggle Expand
                'Expand = (Not Expand)
                'Check if need to expand the control
                'If Expand And ctlExpandStatus Then
                If ctlExpandStatus Then
                    'Collape frame
                    m_OldHeight = UserControl.ScaleHeight * Screen.TwipsPerPixelY
                    UserControl.Height = (TitleHeight * Screen.TwipsPerPixelY) + (TitlePadding + TitlePadding + 1) * Screen.TwipsPerPixelY
                    ctlExpandStatus = False
                Else
                    'Restore frame height
                    UserControl.Height = m_OldHeight
                    ctlExpandStatus = True
                End If
            End If
            RaiseEvent TitleDblClick
        Else
            RaiseEvent PanelDblClick
        End If
        RaiseEvent DblClick
    End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)
    'Set MouseY to mouse Y cord
    MouseY = Y
    'Set the button pressed.
    m_MouseButton = Button
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, _
                                Shift As Integer, _
                                X As Single, _
                                Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next

    If UserControl.Width < 255 Then UserControl.Width = 255
    If UserControl.Height < 255 Then UserControl.Height = 255
    Call RenderFrame
    RaiseEvent Resize
End Sub

Private Sub UserControl_Show()
    Call RenderFrame
End Sub

Private Sub UserControl_Initialize()
    ctlExpandStatus = True
End Sub

Private Sub UserControl_InitProperties()
    'Init propertys
    AllowExpand = False
    Border = True
    BorderColor = &HDBCECC
    Caption = Ambient.DisplayName
    Set UserControl.Font = Ambient.Font
    PanelBackColor = &HF5F5F5
    TitleAlign = 0
    TitleBackColor = &HF2EEEE
    TitleForeColor = vbBlack
    TitlePadding = 4
End Sub

' *********************************************************************************
' CUSTOM ROUTINES
' *********************************************************************************

Private Sub RenderFrame()
    Dim RetVal As Long

    With UserControl
        'Clear control.
        Call .Cls
        'Set the main frame backcolor
        .BackColor = PanelBackColor
        'Get caption height
        TitleHeight = .TextHeight(Caption)
        'Draw the frames title bar
        UserControl.Line (0, 0)-(.ScaleWidth - 1, TitlePadding + TitleHeight + TitlePadding), TitleBackColor, BF

        'Draw the frames title caption border.
        If ctlBorder Then
            UserControl.Line (0, 0)-(.ScaleWidth - 1, TitlePadding + TitleHeight + TitlePadding), BorderColor, B
        Else
            UserControl.Line (0, 0)-(.ScaleWidth - 1, TitlePadding + TitleHeight + TitlePadding), TitleBackColor, B
        End If

        'Align frames caption
        Select Case TitleAlign

            Case 0
                .CurrentX = 5

            Case 1
                .CurrentX = (.ScaleWidth - .TextWidth(Caption)) \ 2

            Case 2
                .CurrentX = (.ScaleWidth - .TextWidth(Caption)) - 5
        End Select
        'Used to center caption
        .CurrentY = (TitleHeight + TitlePadding) - TitleHeight
        'Draw the frame caption
        RetVal = TextOut(.hDC, .CurrentX, .CurrentY, Caption, lstrlen(Caption))

        'Draw the frames border.
        If ctlBorder Then
            UserControl.Line (0, 0)-(.ScaleWidth - 1, .ScaleHeight - 1), BorderColor, B
        Else
            UserControl.Line (0, 0)-(.ScaleWidth - 1, .ScaleHeight - 1), PanelBackColor, B
        End If
    End With
End Sub
